{-# LANGUAGE RankNTypes                 #-}
{-# OPTIONS -Wall #-}


--------------------------------------------------------------------------------
-- |
-- Module      :  ZCSV.ReadCSV
-- Copyright   :  (c) Stephen Tetley 2014
-- License     :  BSD3
--
-- Maintainer  :  stephen.tetley@gmail.com
-- Stability   :  unstable
-- Portability :  GHC
--
-- Parser monad.
--
--------------------------------------------------------------------------------

module ZCSV.ReadCSV where

import ZCSV.FieldParser
import ZCSV.PrimLexer
import ZCSV.Utils

import Control.Applicative
-- import Control.Monad

import qualified Data.Text as T


data Err = LexErr   LineNum ErrMsg String
         | ParseErr LineNum ErrMsg String
  deriving (Eq,Show)


data Ans a = Ans ![Tok] a


newtype CSVParser a = CSVParser { 
    getCSVParser :: [Tok] -> Either Err (Ans a) }

instance Functor CSVParser where
  fmap f ma = CSVParser $ \ts -> 
                getCSVParser ma ts >>= \(Ans ts1 a) -> return (Ans ts1 (f a))

instance Applicative CSVParser where
  pure a    = CSVParser $ \ts -> return (Ans ts a)
  mf <*> ma = CSVParser $ \ts -> 
                getCSVParser mf ts  >>= \(Ans ts1 f) ->
                getCSVParser ma ts1 >>= \(Ans ts2 a) -> 
                return $ Ans ts2 (f a)

instance Monad CSVParser where
  return    = pure
  ma >>= k  = CSVParser $ \ts ->
                getCSVParser ma    ts  >>= \(Ans ts1 a) ->
                getCSVParser (k a) ts1



runCSVParser :: CSVParser a -> T.Text -> Either Err [a]
runCSVParser ma text = let inp = lexer text in runMany ma inp


runCSVParserIO :: CSVParser a -> FilePath -> IO (Either Err [a])
runCSVParserIO ma file_path = runMany ma <$> lexerIO file_path


runCSVParser_header :: CSVParser a -> T.Text -> Either Err ([String], [a])
runCSVParser_header ma text = let ts = lexer text in runWithHeader ma ts 


runCSVParserIO_header :: CSVParser a -> FilePath 
                      -> IO (Either Err ([String],[a]))
runCSVParserIO_header ma file_path = 
    runWithHeader ma <$> lexerIO file_path


runWithHeader :: CSVParser a -> [Tok] -> Either Err ([String], [a])
runWithHeader ma ts = 
    case runOne columns1 ts of
        Left err -> Left err
        Right (ts1, cols) -> case runMany ma ts1 of
            Left err -> Left err
            Right rows -> Right (cols,rows)



runMany :: CSVParser a -> [Tok] -> Either Err [a]
runMany (CSVParser fn) inp = step (fn inp)
  where
    step (Right (Ans [] a)) = Right [a]
    step (Right (Ans xs a)) = case step (fn xs) of
                                Right as -> Right $ a:as
                                Left err -> Left err
    step (Left err)         = Left err


runOne :: CSVParser a -> [Tok] -> Either Err ([Tok],a)
runOne (CSVParser fn) inp = step (fn inp)
  where
    step (Right (Ans xs a)) = Right (xs,a)
    step (Left err)         = Left err


-- | Use another newtype to wrap this?
--
recordParser :: CSVParser a -> CSVParser a
recordParser ma = ma <* endRecord

endRecord :: CSVParser ()
endRecord = CSVParser $ \ts -> case ts of
    []                          -> return $ Ans [] ()
    ((EOL _)            : ts1)  -> return $ Ans ts1 ()
    ((ErrTok i msg inp) : _)    -> Left $ LexErr i msg inp
    ( tok               : _)    -> Left $ ParseErr (tokLineNum tok) tok_msg (tokBody tok)
  where
    tok_msg = "Expecting EOL or EOF"


ignore :: CSVParser ()
ignore = CSVParser $ \ts -> case ts of
    ((Escaped {})       : ts1)  -> return $ Ans ts1 ()
    ((NonEscaped {})    : ts1)  -> return $ Ans ts1 ()
    ((ErrTok i msg inp) : _)    -> Left $ LexErr i msg inp
    ((EOL i) : _)               -> Left $ ParseErr i    "Unexpected EOL" ""
    []                          -> Left $ ParseErr (-1) "Unexpected EOF" ""


field :: FieldParser a -> CSVParser a
field fp = CSVParser $ \ts -> case ts of
    ((Escaped i s)      : ts1)  -> step i s ts1
    ((NonEscaped i s)   : ts1)  -> step i s ts1
    ((ErrTok i msg inp) : _)    -> Left $ LexErr i msg inp
    ((EOL i)            : _)    -> Left $ ParseErr i "Unexpected EOL" ""
    []                          -> Left $ ParseErr (-1) "Unexpecting EOF" ""
  where
    step i inp rest = case runFieldParser fp inp of
                        Nothing -> Left $ ParseErr i "Field parse failure" ""
                        Just a -> return $ Ans rest a



-- | Take contents of first row of tokens
columns1 :: CSVParser [String]
columns1 = CSVParser $ \ts -> step emptyH ts
  where
    step ac ((Escaped _ s)      : ts1)  = step (ac `snocH` s) ts1
    step ac ((NonEscaped _ s)   : ts1)  = step (ac `snocH` s) ts1
    step _  ((ErrTok i msg inp) : _)    = Left $ LexErr i msg inp
    step ac ((EOL _)            : ts1)  = return $ Ans ts1 (toListH ac)
    step ac []                          = return $ Ans [] (toListH ac)


